Some usefull VBA snippets for Microsoft Outlook
Ignore Thread
' Create a rule filtering out mail with the current subject to a hardcoded folder. Only works for MailItems and if only one Mail is selected.
' If zero or more than one mails are selected user will get an error message.
' If you place this as a button to the Quick Access toolbar you can use <alt>-<3> (or a different number, depending on the position in the toolbar)
' to invoke this script.
Sub IngoreThread()
Dim olExplorer As Outlook.Explorer
Dim oMailItem As MailItem
Dim olSelection As Selection
Set olExplorer = Application.ActiveExplorer
' get currently selected items
Set olSelection = olExplorer.Selection
' If less or more than one items are selected, display an error and exit
If olSelection.Count <> 1 Then
MsgBox "Error: Please select exactly one mail", vbCritical
Exit Sub
End If
Set oMailItem = olSelection.Item(1)
createThreadIgnoreRule (oMailItem.subject)
End Sub
' Create a rule for filtering out a certain mailthread. The subject does not need to be sanitized before.
Sub createThreadIgnoreRule(subject As String)
Dim colRules As Outlook.Rules
Dim oRule As Outlook.Rule
Dim colRuleActions As Outlook.RuleActions
Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
Dim oFromCondition As Outlook.ToOrFromRuleCondition
Dim oSubject As Outlook.TextRuleCondition
Dim oInbox As Outlook.Folder
Dim oMoveTarget As Outlook.Folder
Dim sanitizedSubject As String
' sanitize the subject. If it is already calling this function still doesn't matter as the subject just will not be changed then.
sanitizedSubject = sanitizeSubject(subject)
' check if we have already a rule for this subject
If isRuleExisting(sanitizedSubject) = True Then
' Rule already exists, exit
Debug.Print ("Rule for """ & sanitizedSubject & """ is already existing, not creating it again")
Exit Sub
End If
' This will take some time. Show a small message box to inform the user.
ignoreThreadProgress.Show
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
' The target for mails. You can change this to whatever you want. The folder is not autocreated.
Set oMoveTarget = oInbox.Folders("ruletest")
' Get all current rules
Set colRules = Application.Session.DefaultStore.GetRules()
' Create a new rule for the subject. All rules start with "com.nomike.ignorethread." (think java packages here) followed by the
' sanitized subject an underscore and the current date. This way rules are easy to identify and a could be deleted after a defined amout of time
Set oRule = colRules.Create("com.nomike.ignorethread." & sanitizedSubject & "_" & Format(Now, "yyyy-MM-dd"), olRuleReceive)
' Set action of rule to move mails to a folder
Set oMoveRuleAction = oRule.Actions.MoveToFolder
' Configure move action
With oMoveRuleAction
.Enabled = True
.Folder = oMoveTarget
End With
' Set confition of the rule to match a certain subject
Set oSubject = oRule.Conditions.subject
' Configure subject condition
With oSubject
.Enabled = True
.Text = Array(sanitizedSubject)
End With
' Save rule. This usually takes some time (>= 10 seconds)
colRules.Save
' Hide message box
ignoreThreadProgress.Hide
' Execute rule on inbox
oRule.Execute (showProgress = True)
End Sub
' Check if a rule starting for the sanitized subject is already existing
Function isRuleExisting(sanitizedSubject As String) As Boolean
Dim colRules As Outlook.Rules
Dim oRule As Outlook.Rule
' get all rules and loop over them
Set colRules = Application.Session.DefaultStore.GetRules()
For i = colRules.Count To 1 Step -1
Set oRule = colRules.Item(i)
' check if rule is existing
If (InStr(oRule.Name, "com.nomike.ignorethread." & sanitizedSubject) = 1) Then
'rule is existing, return true
isRuleExisting = True
Exit Function
End If
Next
' rule was not found, return false
isRuleExisting = False
Exit Function
End Function
' Remove common prefixes from subject (e.g. "Re: ", "Fwd: ", etc.)
' As localized versions of Outlook use different prefixes, you might need to adapt the subjectPrefixes Array. Currently it should work for english and german.
Function sanitizeSubject(subject As String) As String
Dim changed As Boolean
changed = True
Dim subjectPrefixes As Variant
' Add new prefixes here if they apply to you. The trailing whitespace is not mandatory as the subject is trimmed anyway later.
subjectPrefixes = Array("FWD: ", "RE: ", "FW: ", "WG: ", "AW: ", "WE: ")
' Execute this part as long as something is changed to also deal with "Re: Fwd: AW: Hello world" subjects properly
While changed = True
changed = False
' Loop over all prefixes
For Each Prefix In subjectPrefixes
' Check if subject starts with prefix, convert strings to uppercase for conversion to make it case insensitive
If (InStr(UCase(subject), UCase(Prefix)) = 1) Then
changed = True
' cut out the prefix and additionally trim the subject to remove excess whitespace
subject = Trim(Mid(subject, Len(Prefix) + 1))
End If
Next
Wend
' return the sanitized subject
sanitizeSubject = subject
Exit Function
End Function
Accept Meeting Invitations
Sub AcceptMeetings()
Dim myExplorer As Outlook.explorer
Dim mySelection As selection
Dim myMailItem As Object
Dim myMessageDate As Date
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myArchive As Outlook.MAPIFolder
Dim myMessageYear As Integer
Dim myMeetingItem As Outlook.MeetingItem
Set myNamespace = Outlook.Application.GetNamespace("MAPI")
Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
Set myArchive = myInbox.Folders("Archive")
Set myExplorer = Application.activeExplorer
Set mySelection = myExplorer.selection
For i = 1 To mySelection.Count
Set myMailItem = mySelection.Item(i)
Debug.Print TypeName(myMailItem)
If TypeName(myMailItem) = "MeetingItem" Then
Dim myAppointmentItem As Outlook.AppointmentItem
Set myAppointmentItem = myMailItem.GetAssociatedAppointment(True)
myAppointmentItem.Respond olMeetingAccepted, True
myMailItem.Delete
DoEvents
End If
Next i
End Sub
Archive Mails
Sub ArchiveMail()
Dim myExplorer As Outlook.explorer
Dim mySelection As selection
Dim myMailItem As MailItem
Dim myMessageDate As Date
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myArchive As Outlook.MAPIFolder
Dim myMessageYear As Integer
Set myNamespace = Outlook.Application.GetNamespace("MAPI")
Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
Set myArchive = myInbox.Folders("Archive")
Set myExplorer = Application.activeExplorer
Set mySelection = myExplorer.selection
For i = 1 To mySelection.Count
Set myMailItem = mySelection.Item(i)
myMessageDate = myMailItem.CreationTime
myMessageYear = Year(myMessageDate)
Debug.Print myMessageYear
Debug.Print myMailItem.SenderName
moveMailToArchive myMailItem, myArchive
Next i
End Sub
Sub moveMailToArchive(myMailItem As Outlook.MailItem, myArchiveFolder As
Outlook.MAPIFolder)
Dim myYearFolder As Outlook.MAPIFolder
On Error Resume Next
Set myYearFolder =
myArchiveFolder.Folders(Trim(Str(Year(myMailItem.CreationTime))))
If myYearFolder Is Nothing Then
Set myYearFolder =
myArchiveFolder.Folders.Add(Year(myMailItem.CreationTime))
End If
myMailItem.UnRead = False
myMailItem.Move myYearFolder
End Sub